home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 376-400 / disk_386 / xlispstat / src1.lzh / XLisp / xlsubr.c < prev    next >
C/C++ Source or Header  |  1990-10-03  |  4KB  |  194 lines
  1. /* xlsubr - xlisp builtin function support routines */
  2. /* Copyright (c) 1989, by David Michael Betz.                            */
  3. /* You may give out copies of this software; for conditions see the file */
  4. /* COPYING included with this distribution.                              */
  5.  
  6. #include <string.h>
  7. #include "xlisp.h"
  8. #include "osdef.h"
  9. #ifdef ANSI
  10. #include "xlproto.h"
  11. #else
  12. #include "xlfun.h"
  13. #endif ANSI
  14. #include "xlvar.h"
  15.  
  16. /* xlsubr - define a builtin function */
  17. LVAL xlsubr(sname,type,fcn,offset)
  18.   char *sname; int type; LVAL (*fcn)(); int offset;
  19. {
  20.     LVAL sym;
  21.     sym = xlenter(sname);
  22.     setfunction(sym,cvsubr(fcn,type,offset));
  23.     return (sym);
  24. }
  25.  
  26. /* xlgetkeyarg - get a keyword argument */
  27. int xlgetkeyarg(key,pval)
  28.   LVAL key,*pval;
  29. {
  30.     LVAL *argv /*=xlargv */; /* not needed JKL */
  31.     int argc /*=xlargc*/;    /* not needed JKL */
  32.     for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
  33.     if (*argv == key) {
  34.         *pval = *++argv;
  35.         return (TRUE);
  36.     }
  37.     }
  38.     return (FALSE);
  39. }
  40.  
  41. /* xlgkfixnum - get a fixnum keyword argument */
  42. int xlgkfixnum(key,pval)
  43.   LVAL key,*pval;
  44. {
  45.     if (xlgetkeyarg(key,pval)) {
  46.     if (!fixp(*pval))
  47.         xlbadtype(*pval);
  48.     return (TRUE);
  49.     }
  50.     return (FALSE);
  51. }
  52.  
  53. /* xltest - get the :test or :test-not keyword argument */
  54. void xltest(pfcn,ptresult)
  55.   LVAL *pfcn; int *ptresult;
  56. {
  57.     if (xlgetkeyarg(k_test,pfcn))    /* :test */
  58.     *ptresult = TRUE;
  59.     else if (xlgetkeyarg(k_tnot,pfcn))    /* :test-not */
  60.     *ptresult = FALSE;
  61.     else {
  62.     *pfcn = getfunction(s_eql);
  63.     *ptresult = TRUE;
  64.     }
  65. }
  66.  
  67. /* xlgetfile - get a file or stream */
  68. LVAL xlgetfile()
  69. {
  70.     LVAL arg;
  71.  
  72.     /* get a file or stream (cons) or nil */
  73.     if (arg = xlgetarg()) {
  74.     if (streamp(arg)) {
  75.         if (getfile(arg) == NULL)
  76.         xlfail("file not open");
  77.     }
  78.     else if (!ustreamp(arg))
  79.         xlbadtype(arg);
  80.     }
  81.     return (arg);
  82. }
  83.  
  84. /* xlgetfname - get a filename */
  85. LVAL xlgetfname()
  86. {
  87.     LVAL name;
  88.  
  89.     /* get the next argument */
  90.     name = xlgetarg();
  91.  
  92.     /* get the filename string */
  93.     if (symbolp(name))
  94.     name = getpname(name);
  95.     else if (!stringp(name))
  96.     xlbadtype(name);
  97.  
  98.     /* return the name */
  99.     return (name);
  100. }
  101.  
  102. /* needsextension - check if a filename needs an extension */
  103. int needsextension(name)
  104.   char *name;
  105. {
  106.     char *p;
  107.  
  108.     /* check for an extension */
  109.     for (p = &name[strlen(name)]; --p >= &name[0]; )
  110.     if (*p == '.')
  111.         return (FALSE);
  112.     else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
  113.         return (TRUE);
  114.  
  115.     /* no extension found */
  116.     return (TRUE);
  117. }
  118.  
  119. /* xlbadtype - report a "bad argument type" error */
  120. LVAL xlbadtype(arg)
  121.   LVAL arg;
  122. {
  123.     xlerror("bad argument type",arg);
  124.     return(NIL);  /* to keep compilers happy - L. Tierney */
  125. }
  126.  
  127. /* xltoofew - report a "too few arguments" error */
  128. LVAL xltoofew()
  129. {
  130.     xlfail("too few arguments");
  131.     return(NIL);  /* to keep compilers happy - L. Tierney */
  132. }
  133.  
  134. /* xltoomany - report a "too many arguments" error */
  135. void xltoomany()
  136. {
  137.     xlfail("too many arguments");
  138. }
  139.  
  140. /* eq - internal eq function */
  141. int eq(arg1,arg2)
  142.   LVAL arg1,arg2;
  143. {
  144.     return (arg1 == arg2);
  145. }
  146.  
  147. /* eql - internal eql function */
  148. int eql(arg1,arg2)
  149.   LVAL arg1,arg2;
  150. {
  151.     /* compare the arguments */
  152.     if (arg1 == arg2)
  153.     return (TRUE);
  154.     else if (arg1) {
  155.     switch (ntype(arg1)) {
  156.     case FIXNUM:
  157.         return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  158.     case FLONUM:
  159.         return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  160.     default:
  161.         return (FALSE);
  162.     }
  163.     }
  164.     else
  165.     return (FALSE);
  166. }
  167.  
  168. /* equal - internal equal function */
  169. int equal(arg1,arg2)
  170.   LVAL arg1,arg2;
  171. {
  172.     /* compare the arguments */
  173.     if (arg1 == arg2)
  174.     return (TRUE);
  175.     else if (arg1) {
  176.     switch (ntype(arg1)) {
  177.     case FIXNUM:
  178.         return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  179.     case FLONUM:
  180.         return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  181.     case STRING:
  182.         return (stringp(arg2) ? strcmp(getstring(arg1),
  183.                        getstring(arg2)) == 0 : FALSE);
  184.     case CONS:
  185.         return (consp(arg2) ? equal(car(arg1),car(arg2))
  186.                    && equal(cdr(arg1),cdr(arg2)) : FALSE);
  187.     default:
  188.         return (FALSE);
  189.     }
  190.     }
  191.     else
  192.     return (FALSE);
  193. }
  194.